home *** CD-ROM | disk | FTP | other *** search
/ An Invitation to the Roland World of Music / Roland - An Invitation To The Roland World Of Music.bin / vb / mmsystem / msgblst1 / div_midi.bas next >
BASIC Source File  |  1995-05-30  |  12KB  |  303 lines
  1. Option Explicit
  2. Dim m_hmidiout As Integer
  3. Dim m_dev_id_IN As Integer
  4.  
  5. Dim m_hMidiIn As Integer
  6. Dim m_dev_id_OUT As Integer
  7.  
  8.  
  9. ' **************************************************************************
  10. '
  11. '         Multimedia API Declares adapted from MMSYSTEM.H
  12. '
  13. '         Copyright (c) 1990-1993, Microsoft Corp.  All rights reserved.
  14. '
  15. ' **************************************************************************
  16.  
  17. Global Const MIDIERR_BASE = 64
  18.  
  19. ' ***************************************************************************
  20.  
  21. '                     General constants and data types
  22.  
  23. ' ****************************************************************************/
  24.  
  25. '  general constants
  26. Global Const MAXPNAMELEN = 32           '  max product name length (including NULL)
  27. Global Const MAXERRORLENGTH = 128       '  max error text length (including NULL)
  28.  
  29.  
  30. Global Const MM_MIM_OPEN = &H3C1                    '  MIDI input
  31. Global Const MM_MIM_CLOSE = &H3C2
  32. Global Const MM_MIM_DATA = &H3C3
  33. Global Const MM_MIM_LONGDATA = &H3C4
  34. Global Const MM_MIM_ERROR = &H3C5
  35. Global Const MM_MIM_LONGERROR = &H3C6
  36.  
  37. Global Const MM_MOM_OPEN = &H3C7                    '  MIDI output
  38. Global Const MM_MOM_CLOSE = &H3C8
  39. Global Const MM_MOM_DONE = &H3C9
  40.  
  41. ' ***************************************************************************
  42.  
  43. '                             MIDI audio support
  44.  
  45. ' ****************************************************************************/
  46.  
  47. '  MIDI error return values
  48. Global Const MIDIERR_UNPREPARED = (MIDIERR_BASE + 0)       '  header not prepared
  49. Global Const MIDIERR_STILLPLAYING = (MIDIERR_BASE + 1)     '  still something playing
  50. Global Const MIDIERR_NOMAP = (MIDIERR_BASE + 2)            '  no current map
  51. Global Const MIDIERR_NOTREADY = (MIDIERR_BASE + 3)         '  hardware is still busy
  52. Global Const MIDIERR_NODEVICE = (MIDIERR_BASE + 4)         '  port no longer connected
  53. Global Const MIDIERR_INVALIDSETUP = (MIDIERR_BASE + 5)     '  invalid setup
  54. Global Const MIDIERR_LASTERROR = (MIDIERR_BASE + 5)        '  last error in range
  55.  
  56. Global Const MIDIPATCHSIZE = 128
  57.  
  58. '  MIDI callback messages
  59. Global Const MIM_OPEN = MM_MIM_OPEN
  60. Global Const MIM_CLOSE = MM_MIM_CLOSE
  61. Global Const MIM_DATA = MM_MIM_DATA
  62. Global Const MIM_LONGDATA = MM_MIM_LONGDATA
  63. Global Const MIM_ERROR = MM_MIM_ERROR
  64. Global Const MIM_LONGERROR = MM_MIM_LONGERROR
  65. Global Const MOM_OPEN = MM_MOM_OPEN
  66. Global Const MOM_CLOSE = MM_MOM_CLOSE
  67. Global Const MOM_DONE = MM_MOM_DONE
  68.  
  69. '  device ID for MIDI mapper
  70. Global Const MIDIMAPPER = (-1)
  71. Global Const MIDI_MAPPER = (-1)
  72.  
  73. '  flags for wFlags parm of midiOutCachePatches(), midiOutCacheDrumPatches()
  74. Global Const MIDI_CACHE_ALL = 1
  75. Global Const MIDI_CACHE_BESTFIT = 2
  76. Global Const MIDI_CACHE_QUERY = 3
  77. Global Const MIDI_UNCACHE = 4
  78.  
  79. '  MIDI output device capabilities structure
  80. Type MIDIOUTCAPS
  81.     wMid As Integer                  '  manufacturer ID
  82.     wPid As Integer                  '  product ID
  83.     vDriverVersion As Integer        '  version of the driver
  84.     szpname As String * MAXPNAMELEN  '  product name (NULL terminated string)
  85.     wTechnology As Integer           '  type of device
  86.     wVoices As Integer               '  # of voices (internal synth only)
  87.     wNotes As Integer                '  max # of notes (internal synth only)
  88.     wChannelMask As Integer          '  channels used (internal synth only)
  89.     dwSupport As Long             '  functionality supported by driver
  90. End Type
  91.  
  92. '  flags for wTechnology field of MIDIOUTCAPS structure
  93. Global Const MOD_MIDIPORT = 1      '  output port
  94. Global Const MOD_SYNTH = 2         '  generic internal synth
  95. Global Const MOD_SQSYNTH = 3       '  square wave internal synth
  96. Global Const MOD_FMSYNTH = 4       '  FM internal synth
  97. Global Const MOD_MAPPER = 5        '  MIDI mapper
  98.  
  99. '  flags for dwSupport field of MIDIOUTCAPS structure
  100. Global Const MIDICAPS_VOLUME = &H1               '  supports volume control
  101. Global Const MIDICAPS_LRVOLUME = &H2             '  separate left-right volume control
  102. Global Const MIDICAPS_CACHE = &H4
  103.  
  104. '  MIDI output device capabilities structure
  105. Type MIDIINCAPS
  106.     wMid As Integer                  '  manufacturer ID
  107.     wPid As Integer                  '  product ID
  108.     vDriverVersion As Integer        '  version of the driver
  109.     szpname As String * MAXPNAMELEN  '  product name (NULL terminated string)
  110. End Type
  111.  
  112. '  MIDI data block header
  113. Type MIDIHDR
  114.     lpData As Long               '  pointer to locked data block
  115.     dwBufferLength As Long       '  length of data in data block
  116.     dwBytesRecorded As Long      '  used for input only
  117.     dwUser As Long               '  for client's use
  118.     dwFlags As Long              '  assorted flags (see defines)
  119.     midihdr_tag As Long          '  reserved for driver
  120.     reserved As Long             '  reserved for driver
  121. End Type
  122.  
  123. '  flags for dwFlags field of MIDIHDR structure
  124. Global Const MHDR_DONE = &H1                     '  done bit
  125. Global Const MHDR_PREPARED = &H2                 '  set if header prepared
  126. Global Const MHDR_INQUEUE = &H4                  '  reserved for driver
  127.  
  128. ' ***************************************************************************
  129.  
  130. '                           Driver callback support
  131.  
  132. ' ****************************************************************************/
  133.  
  134. '  flags used with waveOutOpen(), waveInOpen(), midiInOpen(), and
  135. '  midiOutOpen() to specify the type of the dwCallback parameter.
  136.  
  137. Global Const CALLBACK_TYPEMASK = &H70000           '  callback type mask
  138. Global Const CALLBACK_NULL = &H0&                  '  no callback
  139. Global Const CALLBACK_WINDOW = &H10000             '  dwCallback is a HWND
  140. Global Const CALLBACK_TASK = &H20000               '  dwCallback is a HTASK
  141. Global Const CALLBACK_FUNCTION = &H30000           '  dwCallback is a FARPROC
  142.  
  143. '  MIDI function prototypes
  144. Declare Function midiOutGetNumDevs Lib "MMSYSTEM" () As Integer
  145. Declare Function midiOutGetDevCaps Lib "MMSYSTEM" (ByVal udeviceid As Integer, lpCaps As MIDIOUTCAPS, ByVal uSize As Integer) As Integer
  146. Declare Function midiOutGetVolume Lib "MMSYSTEM" (ByVal udeviceid As Integer, lpdwvolume As Long) As Integer
  147. Declare Function midiOutSetVolume Lib "MMSYSTEM" (ByVal udeviceid As Integer, ByVal dwVolume As Long) As Integer
  148. Declare Function midiOutGetErrorText Lib "MMSYSTEM" (ByVal uError As Integer, ByVal lpText As String, ByVal uSize As Integer) As Integer
  149. Declare Function midiOutOpen Lib "MMSYSTEM" (lphMidiOut As Integer, ByVal udeviceid As Integer, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Integer
  150. Declare Function midiOutClose Lib "MMSYSTEM" (ByVal hmidiout As Integer) As Integer
  151. Declare Function midiOutPrepareHeader Lib "MMSYSTEM" (ByVal hmidiout As Integer, lphMidiOut As MIDIHDR, ByVal uSize As Integer) As Integer
  152. Declare Function midiOutUnprepareHeader Lib "MMSYSTEM" (ByVal hmidiout As Integer, lphMidiOut As MIDIHDR, ByVal uSize As Integer) As Integer
  153. Declare Function midiOutShortMsg Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal dwMsg As Long) As Integer
  154. Declare Function midiOutLongMsg Lib "MMSYSTEM" (ByVal hmidiout As Integer, lphMidiOut As MIDIHDR, ByVal uSize As Integer) As Integer
  155. Declare Function midiOutReset Lib "MMSYSTEM" (ByVal hmidiout As Integer) As Integer
  156. Declare Function midiOutCachePatches Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal uBank As Integer, ByVal PatchArray As Long, ByVal uFlags As Integer) As Integer
  157. Declare Function midiOutCacheDrumPatches Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal uPatch As Integer, lpwKeyArray As Integer, ByVal uFlags As Integer) As Integer
  158. Declare Function midiOutGetID Lib "MMSYSTEM" (ByVal hmidiout As Integer, lpudeviceid As Integer) As Integer
  159. Declare Function midiOutMessage Lib "MMSYSTEM" (ByVal hmidiout As Integer, ByVal uMessage As Integer, ByVal dw1 As Long, ByVal dw2 As Long) As Long
  160.  
  161. Declare Function midiInGetNumDevs Lib "MMSYSTEM" () As Integer
  162. Declare Function midiInGetDevCaps Lib "MMSYSTEM" (ByVal udeviceid As Integer, lpCaps As MIDIINCAPS, ByVal uSize As Integer) As Integer
  163. Declare Function midiInGetErrorText Lib "MMSYSTEM" (ByVal uError As Integer, ByVal lpText As String, ByVal uSize As Integer) As Integer
  164. Declare Function midiInOpen Lib "MMSYSTEM" (lphMidiIn As Integer, ByVal udeviceid As Integer, ByVal dwCallback As Long, ByVal dwInstance As Long, ByVal dwFlags As Long) As Integer
  165. Declare Function midiInClose Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  166. Declare Function midiInPrepareHeader Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpMidiInHdr As MIDIHDR, ByVal uSize As Integer) As Integer
  167. Declare Function midiInUnprepareHeader Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpMidiInHdr As MIDIHDR, ByVal uSize As Integer) As Integer
  168. Declare Function midiInAddBuffer Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpMidiInHdr As MIDIHDR, ByVal uSize As Integer) As Integer
  169. Declare Function midiInStart Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  170. Declare Function midiInStop Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  171. Declare Function midiInReset Lib "MMSYSTEM" (ByVal hMidiIn As Integer) As Integer
  172. Declare Function midiInGetID Lib "MMSYSTEM" (ByVal hMidiIn As Integer, lpudeviceid As Integer) As Integer
  173. Declare Function midiInMessage Lib "MMSYSTEM" (ByVal hMidiIn As Integer, ByVal uMessage As Integer, ByVal dw1 As Long, ByVal dw2 As Long) As Long
  174.  
  175. Sub inerr (ByVal merr As Integer)
  176. Dim s As String
  177. Dim x As Integer
  178.  
  179.     s = Space(MAXERRORLENGTH)
  180.     x = midiInGetErrorText(merr, s, MAXERRORLENGTH)
  181.     'If Not gdebug Then
  182.         MsgBox s
  183.     'End If
  184. End Sub
  185.  
  186. Sub midi_in_close ()
  187. Dim merr As Integer
  188.  
  189.     If m_hMidiIn <> 0 Then
  190.         merr = midiInClose(m_hMidiIn)
  191.         If Not merr = 0 Then
  192.             Call inerr(merr)
  193.         End If
  194.         m_hMidiIn = 0
  195.     End If
  196. End Sub
  197.  
  198. Function midi_in_get_dev () As Integer
  199.     midi_in_get_dev = m_dev_id_IN
  200. End Function
  201.  
  202. Function midi_in_open (ByVal h_wnd As Integer) As Integer
  203. Dim merr As Integer
  204. '
  205.     midi_in_close ' just in case (And it dont hurt)
  206.     merr = midiInOpen(m_hMidiIn, m_dev_id_IN, h_wnd, 0, CALLBACK_WINDOW)
  207.     If Not merr = 0 Then
  208.         Call inerr(merr)
  209.     End If
  210.     midi_in_open = (m_hMidiIn <> 0)
  211. End Function
  212.  
  213. Sub midi_in_set_dev (ByVal ldev As Integer)
  214.     m_dev_id_IN = ldev
  215. End Sub
  216.  
  217. Function midi_out_open () As Integer
  218. Dim merr As Integer
  219.  
  220.     midi_out_close ' just in case (And it dont hurt)
  221.     merr = midiOutOpen(m_hmidiout, m_dev_id_OUT, 0, 0, 0)
  222.     If Not merr = 0 Then
  223.         Call outerr(merr)
  224.     End If
  225.     midi_out_open = (m_hmidiout <> 0)
  226. End Function
  227.  
  228.  
  229. Sub midi_out_set_dev (ByVal ldev As Integer)
  230.     m_dev_id_OUT = ldev
  231. End Sub
  232.  
  233. Sub midi_outshort_raw (ByVal d As Long)
  234. Dim x As Integer
  235.     x = midiOutShortMsg(m_hmidiout, d)
  236. End Sub
  237.  
  238. Sub midi_start_rec ()
  239. Dim merr As Integer
  240.  
  241.     merr = midiInStart(m_hMidiIn)
  242.     If Not merr = 0 Then
  243.         Call inerr(merr)
  244.     End If
  245. End Sub
  246.  
  247. Sub midi_stop_rec ()
  248. Dim merr As Integer
  249.  
  250.     merr = midiInStop(m_hMidiIn)
  251.     If Not merr = 0 Then
  252.         Call inerr(merr)
  253.     End If
  254. End Sub
  255.  
  256. Sub outerr (ByVal merr As Integer)
  257. Dim s As String
  258. Dim x As Integer
  259.  
  260.     s = Space(MAXERRORLENGTH)
  261.     x = midiOutGetErrorText(merr, s, MAXERRORLENGTH)
  262.     'If Not gdebug Then
  263.         MsgBox s
  264.     'End If
  265. End Sub
  266.  
  267. Sub init_combo_dev_in (c As Control)
  268. Dim incaps As MIDIINCAPS
  269. Dim i As Integer
  270.  
  271.     For i = -1 To midiInGetNumDevs()
  272.         If 0 = midiInGetDevCaps(i, incaps, Len(incaps)) Then
  273.             c.AddItem incaps.szpname
  274.             c.ItemData(c.NewIndex) = i
  275.         End If
  276.     Next
  277. End Sub
  278.  
  279. Sub init_combo_dev_out (c As Control)
  280. Dim outcaps As MIDIOUTCAPS
  281. Dim i As Integer
  282.  
  283.     For i = -1 To midiOutGetNumDevs()
  284.         If 0 = midiOutGetDevCaps(i, outcaps, Len(outcaps)) Then
  285.             c.AddItem outcaps.szpname
  286.             c.ItemData(c.NewIndex) = i
  287.         End If
  288.     Next
  289. End Sub
  290.  
  291. Sub midi_out_close ()
  292. Dim merr As Integer
  293.  
  294.     If m_hmidiout <> 0 Then
  295.         merr = midiOutClose(m_hmidiout)
  296.         If Not merr = 0 Then
  297.             Call outerr(merr)
  298.         End If
  299.         m_hmidiout = 0
  300.     End If
  301. End Sub
  302.  
  303.